home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / select-rectangle.lisp / select-rectangle.lisp
Encoding:
Text File  |  1992-03-14  |  4.5 KB  |  149 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;;Select-Rectangle.Lisp
  4. ;;
  5. ;;Copyright © 1987-89, Apple Computer, Inc
  6. ;;
  7. ;;
  8. ;;  This file has some examples of making trap calls and using window.
  9. ;;
  10. ;;  It implements a function for dragging out a gray rectangle.
  11. ;;  Then it shows how to use this function to create a new class of windows.
  12. ;;
  13. ;
  14. ;  Changes:
  15. ;
  16. ;20-Sep-90 mc    Changed select-rectangle to be a *view* method and changed
  17. ;         with-port to with-focused-view
  18. ;10-Oct-90 mc    Had to add with-focused-view to
  19. ;        (window-click-event-handler mondrian-window) (why now?).
  20. ;        Commented out mondrian-window code.
  21. ;        Added optional the-anchor-point arg to select-rectangle.
  22. ;        Added provide, *features*
  23. ;25-May-91 mc    Converted to mcl 2.0b1
  24. ;14-Mar-92 mc    Commented out the loading of records.lisp
  25. ;
  26. ;;
  27.  
  28. (in-package "CCL")
  29.  
  30. (export '(SELECT-RECTANGLE))
  31.  
  32.  
  33. (pushnew :select-rectangle *features*)
  34. (provide :select-rectangle)
  35.  
  36.  
  37. ;;;;;;;;;;;;;;;;;;
  38. ;;
  39. ;;select-rectangle
  40. ;;
  41. ;;  returns multiple values giving the two corner points of the
  42. ;;  selected rectangle.
  43. ;;
  44.  
  45. (defmethod select-rectangle ((self view) &optional the-anchor-point)
  46.   "THE-ANCHOR-POINT specifies the upper left position from which the rect
  47. will be drawn and defaults to view-mouse-position."
  48.   ;;
  49.   (with-focused-view self
  50.     ;; Type check optional args.
  51.     (when (and the-anchor-point
  52.                (not (integerp the-anchor-point)))
  53.       (error "The-anchor-point ~S not a Macintosh point (integer)"
  54.              the-anchor-point))
  55.     ;;
  56.     (let* ((anchor-point (or the-anchor-point (view-mouse-position self)))
  57.            (old-mouse (view-mouse-position self))
  58.            (new-mouse old-mouse))
  59.       (rlet ((r :rect)
  60.              (old-pen-state :penstate))
  61.         (#_GetPenState :ptr old-pen-state)
  62.         (#_PenMode :word (position :patxor *pen-modes*))
  63.         (rset (wptr self) grafPort.pnPat *gray-pattern*)
  64.         (#_pt2rect :long anchor-point :long new-mouse :ptr r)
  65.         (#_FrameRect :ptr r)
  66.         (loop
  67.           (unless (mouse-down-p) (return))     ;return when the mouse lets up
  68.           (unless (eq old-mouse new-mouse)
  69.             (#_FrameRect :ptr r)
  70.             (#_pt2rect :long anchor-point :long new-mouse :ptr r)
  71.             (#_FrameRect :ptr r)
  72.             (sleep 1/60)
  73.             (setq old-mouse new-mouse))
  74.           (setq new-mouse (view-mouse-position self)))
  75.         (#_FrameRect :ptr r)
  76.         (#_SetPenState :ptr old-pen-state)
  77.         (values (rref r rect.topleft)
  78.                 (rref r rect.bottomright))))))
  79.  
  80.  
  81. #|
  82. ;;;;;;;;;;;;;;;;;;;;
  83. ;;
  84. ;; mondrian-window
  85. ;;
  86. ;;  a class of windows that lets you draw rectangle pictures
  87.  
  88. (defclass mondrian-view (view)
  89.   ())
  90.  
  91. (defmethod view-click-event-handler ((self mondrian-view) where)
  92.   (declare (ignore where))
  93.   ;;
  94.   (multiple-value-bind (topleft bottomright) (select-rectangle self ;#@(100 100)
  95.                                                                )
  96.     (rlet ((my-rect :rect))
  97.       (rset my-rect rect.topleft topleft)
  98.       (rset my-rect rect.bottomright bottomright)
  99.       (with-focused-view self
  100.         (#_InvertRect :ptr my-rect)))))
  101.  
  102. (defclass mondrian-window (mondrian-view window)
  103.   ())
  104.  
  105. (make-instance 'mondrian-window)
  106.  
  107.  
  108. ;;;;;;;;;;;;;;;;;;;;
  109. ;;
  110. ;; Selecting-scroller
  111. ;;
  112. ;;  A class of windows that tests select-rectangle on nested scrollers.
  113.  
  114. (require "SCROLLERS")
  115.  
  116.  
  117. (defclass scroller2 (scroller mondrian-view) ())
  118.  
  119. (defmethod scroll-bar-limits ((view scroller2))
  120.   (normal-scroll-bar-limits view 300 300))
  121.  
  122. (defmethod view-draw-contents ((self scroller2))
  123.   (frame-rect self 110 10 170 170)
  124.   (call-next-method))
  125.  
  126. (defclass scroller3 (scroller mondrian-view) ())
  127.  
  128. (defmethod scroll-bar-limits ((view scroller3))
  129.   (normal-scroll-bar-limits view 170 170))
  130.  
  131. (defmethod view-draw-contents ((self scroller3))
  132.   (paint-oval self 10 10 70 70)
  133.   (paint-oval self 70 70 170 170)
  134.   (call-next-method))
  135.  
  136. (let* ((dial (make-instance 'dialog))
  137.        (first-scroller (make-instance 'scroller2
  138.                                       :view-container dial
  139.                                       :view-size #@(180 180)
  140.                                       :view-position #@(5 5)
  141.                                       :track-thumb-p t))
  142.        (second-scroller (make-instance 'scroller3
  143.                                        :view-container first-scroller
  144.                                        :view-size #@(75 155)
  145.                                        :view-position #@(10 10)
  146.                                        :track-thumb-p t)))
  147.   (list dial first-scroller second-scroller))
  148.  
  149. |#